home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Internet Tools 1993 July / Internet Tools.iso / RockRidge / mail / pine / imap-3.0 / MM-D / imap2 next >
Encoding:
Text File  |  1988-12-24  |  39.3 KB  |  732 lines
  1. (DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10)
  2. (FILECREATED " 7-Jun-88 13:08:02" {SAFE}</B/MRC>IMAP2.;67 39085  
  3.  
  4.       previous date%: "26-May-88 09:29:14" 
  5. |{MCS:MCS:STANFORD}<LANE>MM>IMAP2.;17|)
  6.  
  7.  
  8. (PRETTYCOMPRINT IMAP2COMS)
  9.  
  10. (RPAQQ IMAP2COMS 
  11.        (                                       (* ; 
  12.                            "Interim Mail Access Protocol II --- Mark Crispin")
  13.                                                (* ; 
  14.             "Mail Access Protocol routines --- interface between IMAP and MM")
  15.         (FNS MAP.OPEN MAP.CLOSE MAP.SELECT MAP.FETCHFLAGS MAP.FETCHENVELOPE 
  16.              MAP.FETCHMESSAGE MAP.FETCHHEADER MAP.FETCHFROMSTRING 
  17.              MAP.FETCHSUBJECT MAP.SETFLAG MAP.CLEARFLAG MAP.CHECKMAILBOX 
  18.              MAP.EXPUNGEMAILBOX MAP.COPYMESSAGE MAP.MOVEMESSAGE MAP.ELT 
  19.              MAP.LOCKED?)
  20.                                                (* ; 
  21.                               "Interim Mail Access Protocol support routines")
  22.         (FNS IMAP.OPEN IMAP.OPEN.TCP IMAP.LOGIN IMAP.LOGOUT IMAP.NOOP 
  23.              IMAP.SELECT IMAP.SEND IMAP.REPLY IMAP.PARSE.UNSOLICITED 
  24.              IMAP.EXISTS IMAP.RECENT IMAP.EXPUNGED IMAP.SEARCHED 
  25.              IMAP.PARSE.DATA IMAP.READ IMAP.READ.ITEM IMAP.LOCK IMAP.UNLOCK 
  26.              IMAP.LOCKED?)
  27.                                                (* ; "IMAP contact ports")
  28.         (CONSTANTS (IMAP.PORT.TCP 143))
  29.                                                (* ; 
  30.                                              "Single line string readtable")
  31.         [INITVARS (IMAP.CR.RDTBL (COPYREADTABLE 'ORIG]
  32.         (P (for I from 0 to 127 do (SETSYNTAX I 'OTHER IMAP.CR.RDTBL))
  33.            (SETSYNTAX (CHARCODE CR)
  34.                   'BREAKCHAR IMAP.CR.RDTBL))
  35.                                                (* ; 
  36.                                         "Commonly used strings and bittables")
  37.         [INITVARS [MAP.CRLF (CONCAT (CHARACTER (CHARCODE CR))
  38.                                    (CHARACTER (CHARCODE LF]
  39.                (MAP.LOOKAHEAD 20)
  40.                [IMAP.SPACEBITTABLE (MAKEBITTABLE (LIST (CHARCODE SPACE]
  41.                (IMAP.ARGBITTABLE (MAKEBITTABLE (LIST (CHARCODE CR)
  42.                                                      (CHARCODE "%"")
  43.                                                      (CHARCODE {]
  44.                                                (* ; 
  45.                                              "IMAP user-settable parameters")
  46.         (INITVARS (IMAP.PROTOCOL 'TCP)
  47.                (IMAP.DEBUG NIL)
  48.                (IMAP.GAG T)
  49.                (IMAP.LOCKDEBUG NIL))
  50.                                                (* ; "Declare all globals")
  51.         (GLOBALVARS MAP.CRLF MAP.LOOKAHEAD IMAP.SPACEBITTABLE IMAP.ARGBITTABLE
  52.                IMAP.CR.RDTBL IMAP.PORT.TCP IMAP.PROTOCOL IMAP.DEBUG IMAP.GAG 
  53.                IMAP.LOCKDEBUG PROMPTWINDOW)
  54.                                                (* ; "IMAP reply record")
  55.         (RECORDS IMAP.PARSEDREPLY)))
  56.  
  57.  
  58.  
  59. (* ; "Interim Mail Access Protocol II --- Mark Crispin")
  60.  
  61.  
  62.  
  63.  
  64. (* ; "Mail Access Protocol routines --- interface between IMAP and MM")
  65.  
  66. (DEFINEQ
  67.  
  68. (MAP.OPEN
  69.   [LAMBDA (NAME OLDSTREAM)                               (* ; "Edited 29-Apr-88 19:18 by MRC")
  70.                                                              (* ; "Mail Access Protocol open")
  71.     (PROG ((HOST (FILENAMEFIELD NAME 'HOST))
  72.            (WINDOW PROMPTWINDOW)
  73.            STREAM OLDHOST NMSGS)
  74.           (if OLDSTREAM
  75.               then (SETQ OLDHOST (STREAMPROP OLDSTREAM 'HOST))
  76.                     [SETQ WINDOW (GETPROMPTWINDOW (STREAMPROP OLDSTREAM 'TWINDOW]
  77.                     (if (AND (EQ (U-CASE HOST)
  78.                                      (U-CASE OLDHOST))
  79.                                  (SETQ STREAM (IMAP.NOOP OLDSTREAM)))
  80.                         then (printout WINDOW T "Reusing connection to " HOST)
  81.                       else (printout WINDOW T "Closing connection to " OLDHOST)
  82.                             (IMAP.LOGOUT OLDSTREAM)))
  83.           (if (AND (OR STREAM (AND (SETQ STREAM (IMAP.OPEN HOST))
  84.                                        (EQ 'OK (fetch (IMAP.PARSEDREPLY KEY) of (IMAP.REPLY
  85.                                                                                          STREAM)))
  86.                                        (IMAP.LOGIN STREAM HOST)))
  87.                        (IMAP.SELECT STREAM (PACKFILENAME 'HOST NIL 'BODY NAME))
  88.                        (SETQ NMSGS (STREAMPROP STREAM 'NMSGS))
  89.                        (GEQ NMSGS 1))
  90.               then (STREAMPROP STREAM 'HOST HOST)
  91.                     (RETURN STREAM)
  92.             else (if (ZEROP NMSGS)
  93.                          then (printout WINDOW T "Mailbox is empty"))
  94.                   (IMAP.LOGOUT STREAM])
  95.  
  96. (MAP.CLOSE
  97.   [LAMBDA (STREAM)                                       (* ; "Edited  6-Jul-87 16:12 by MRC")
  98.                                                              (* ; 
  99.                                                            "Here to break any protocol connections")
  100.     (if (OPENP STREAM)
  101.         then (IMAP.LOGOUT STREAM])
  102.  
  103. (MAP.SELECT
  104.   [LAMBDA (STREAM CRITERIA)                              (* ; "Edited 26-Oct-87 18:24 by MRC")
  105.                                                              (* ; 
  106.                                                            "Do a search with the given criteria")
  107.     (IMAP.SEND STREAM 'SEARCH CRITERIA])
  108.  
  109. (MAP.FETCHFLAGS
  110.   [LAMBDA (STREAM FIRST LAST)                            (* ; "Edited 25-Feb-88 18:25 by MRC")
  111.                                                              (* ; "Fetch fast mailbox properties")
  112.     (IMAP.SEND STREAM 'FETCH `(,(if (EQ FIRST LAST)
  113.                                         then FIRST
  114.                                       else (CONCAT FIRST ":" LAST))
  115.                                    FAST])
  116.  
  117. (MAP.FETCHENVELOPE
  118.   [LAMBDA (STREAM MESSAGEARRAY MSG)                      (* ; "Edited 27-Apr-88 15:51 by cdl")
  119.                                                              (* ; 
  120.                                                            "Fetch  envelope for the given message")
  121.     (OR (fetch (MM.CACHE Envelope) of (MAP.ELT MESSAGEARRAY MSG))
  122.         (LET ((NMSGS (GETSTREAMPROP STREAM 'NMSGS))
  123.               LAST)
  124.              (if (AND MAP.LOOKAHEAD (LESSP MSG NMSGS))
  125.                  then (for old LAST from (ADD1 MSG)
  126.                              to (MIN NMSGS (PLUS MSG MAP.LOOKAHEAD))
  127.                              until (fetch (MM.CACHE Envelope) of (MAP.ELT 
  128.                                                                                     MESSAGEARRAY LAST
  129.                                                                                     )) do))
  130.              (IMAP.SEND STREAM 'FETCH `(,(if LAST
  131.                                                  then (CONCAT MSG ":" (SUB1 LAST))
  132.                                                else MSG)
  133.                                             ALL))
  134.              (fetch (MM.CACHE Envelope) of (MAP.ELT MESSAGEARRAY MSG])
  135.  
  136. (MAP.FETCHMESSAGE
  137.   [LAMBDA (STREAM MESSAGEARRAY MSG)                      (* ; "Edited 26-Jan-88 16:48 by MRC")
  138.                                                              (* ; 
  139.                                                            "Fetch text for the given message")
  140.     (IMAP.SEND STREAM 'FETCH `(,MSG RFC822))
  141.     (fetch (MM.CACHE RFC822.Stream) of (MAP.ELT MESSAGEARRAY MSG])
  142.  
  143. (MAP.FETCHHEADER
  144.   [LAMBDA (STREAM MESSAGEARRAY MSG)                      (* ; "Edited 26-Jan-88 17:31 by MRC")
  145.                                                              (* ; 
  146.                                                         "Fetch RFC822 header for the given message")
  147.     (IMAP.SEND STREAM 'FETCH `(,MSG RFC822.HEADER))
  148.     (fetch RFC822.Header of (MAP.ELT MESSAGEARRAY MSG])
  149.  
  150. (MAP.FETCHFROMSTRING
  151.   [LAMBDA (STREAM MESSAGEARRAY MSG MAXFROMLENGTH)        (* ; "Edited 30-Mar-88 09:28 by cdl")
  152.                                                              (* ; "Return human-readable From")
  153.     (LET (TEXT ENV ADDRESS)
  154.          (with MM.CACHE (MAP.ELT MESSAGEARRAY MSG)
  155.                 (SETQ FromText (ALLOCSTRING MAXFROMLENGTH (CHARCODE SPACE)))
  156.                 [if [AND (SETQ ENV (OR Envelope (MAP.FETCHENVELOPE STREAM MESSAGEARRAY MSG)))
  157.                              (SETQ ADDRESS (CAR (fetch (MM.MESSAGE From) of ENV]
  158.                     then (with MM.ADDRESS ADDRESS
  159.                                     (SETQ TEXT (OR PersonalName
  160.                                                    (if Mailbox
  161.                                                        then (if Host
  162.                                                                     then (CONCAT Mailbox "@" Host
  163.                                                                                     )
  164.                                                                   else Mailbox]
  165.                 (if TEXT
  166.                     then (RPLSTRING FromText 1 (if (GREATERP (NCHARS TEXT)
  167.                                                                   MAXFROMLENGTH)
  168.                                                        then (SUBSTRING TEXT 1 MAXFROMLENGTH)
  169.                                                      else TEXT))
  170.                   else FromText])
  171.  
  172. (MAP.FETCHSUBJECT
  173.   [LAMBDA (STREAM MESSAGEARRAY MSG MAXSUBJECTLENGTH)     (* ; "Edited 15-Dec-87 18:18 by MRC")
  174.                                                              (* ; "Return Subject")
  175.     (LET (SUB ENV)
  176.          (with MM.CACHE (MAP.ELT MESSAGEARRAY MSG)
  177.                 (SETQ SubjectText (if (AND (SETQ ENV (OR Envelope (MAP.FETCHENVELOPE STREAM 
  178.                                                                              MESSAGEARRAY MSG)))
  179.                                                (SETQ SUB (fetch (MM.MESSAGE Subject) of
  180.                                                                                          ENV)))
  181.                                       then (if (GREATERP (NCHARS SUB)
  182.                                                               MAXSUBJECTLENGTH)
  183.                                                    then (SUBSTRING SUB 1 MAXSUBJECTLENGTH)
  184.                                                  else SUB)
  185.                                     else " "])
  186.  
  187. (MAP.SETFLAG
  188.   [LAMBDA (STREAM SEQUENCE FLAG)                         (* ; "Edited 10-Mar-88 12:14 by MRC")
  189.                                                              (* ; 
  190.                                                            "Set a flag in the message's flaglst")
  191.     (if FLAG
  192.         then (if (LISTP FLAG)
  193.                      then (SETQ FLAG (CAR FLAG)))        (* ; "MM.MENU returns (LIST FLAG)")
  194.               (LET [(REPLY (IMAP.SEND STREAM 'STORE (LIST SEQUENCE '+Flags FLAG]
  195.                    (with IMAP.PARSEDREPLY REPLY (if (NEQ 'OK KEY)
  196.                                                         then (printout PROMPTWINDOW T 
  197.                                                                         "Set flag rejected: " TEXT])
  198.  
  199. (MAP.CLEARFLAG
  200.   [LAMBDA (STREAM SEQUENCE FLAG)                         (* ; "Edited 10-Mar-88 12:15 by MRC")
  201.                                                              (* ; 
  202.                                                            "Clear a flag in the message's flaglst")
  203.     (if FLAG
  204.         then (if (LISTP FLAG)
  205.                      then (SETQ FLAG (CAR FLAG)))        (* ; "MM.MENU returns (LIST FLAG)")
  206.               (LET [(REPLY (IMAP.SEND STREAM 'STORE (LIST SEQUENCE '-Flags FLAG]
  207.                    (with IMAP.PARSEDREPLY REPLY (if (NEQ 'OK KEY)
  208.                                                         then (printout PROMPTWINDOW T 
  209.                                                                         "Clear flag rejected: " TEXT])
  210.  
  211. (MAP.CHECKMAILBOX
  212.   [LAMBDA (STREAM)                                       (* ; "Edited 20-May-88 12:16 by MRC")
  213.                                                              (* ; "Check for new messages")
  214.     (PROG ([WINDOW (GETPROMPTWINDOW (STREAMPROP STREAM 'TWINDOW]
  215.            REPLY)
  216.           (PRINTOUT WINDOW T)
  217.           (with IMAP.PARSEDREPLY (SETQ REPLY (IMAP.SEND STREAM 'CHECK))
  218.                  (if (EQ 'OK KEY)
  219.                      then (printout WINDOW T "Check completed")
  220.                            (RETURN REPLY)
  221.                    else (printout WINDOW T "Check rejected: " TEXT])
  222.  
  223. (MAP.EXPUNGEMAILBOX
  224.   [LAMBDA (STREAM)                                       (* ; "Edited 20-May-88 12:16 by MRC")
  225.                                                              (* ; "Expunges the mailbox")
  226.     (PROG ([WINDOW (GETPROMPTWINDOW (STREAMPROP STREAM 'TWINDOW]
  227.            REPLY)
  228.           (PRINTOUT WINDOW T)
  229.           (with IMAP.PARSEDREPLY (SETQ REPLY (IMAP.SEND STREAM 'EXPUNGE))
  230.                  (if (EQ 'OK KEY)
  231.                      then (if [AND TEXT (NOT (EQUAL TEXT (CONSTANT null]
  232.                                   then                   (* ; 
  233.                                                      "Message from IMAP server is more interesting")
  234.                                         (printout WINDOW T TEXT)
  235.                                 else (printout WINDOW T "Expunge Completed"))
  236.                            (RETURN REPLY)
  237.                    else (printout WINDOW T "Expunge rejected: " TEXT])
  238.  
  239. (MAP.COPYMESSAGE
  240.   [LAMBDA (STREAM MSGNO DESTMAILBOX)                     (* ; "Edited 25-Apr-88 15:21 by cdl")
  241.                                                              (* ; "Copy mailbox to destination")
  242.     (PROG ([WINDOW (GETPROMPTWINDOW (STREAMPROP STREAM 'TWINDOW]
  243.            REPLY)
  244.           (PRINTOUT WINDOW T)
  245.           (if DESTMAILBOX
  246.               then (with IMAP.PARSEDREPLY (SETQ REPLY (IMAP.SEND STREAM 'COPY
  247.                                                                      (LIST MSGNO DESTMAILBOX)))
  248.                               (if (EQ 'OK KEY)
  249.                                   then (MAP.SETFLAG STREAM MSGNO '\Seen)
  250.                                         (RETURN DESTMAILBOX)
  251.                                 else (printout WINDOW "Copy rejected: " TEXT)))
  252.             else (printout WINDOW "Copy aborted.")
  253.                   NIL])
  254.  
  255. (MAP.MOVEMESSAGE
  256.   [LAMBDA (STREAM MSGNO DESTMAILBOX)                     (* ; "Edited  3-Mar-88 17:40 by MRC")
  257.                                                              (* ; "Copy mailbox to destination")
  258.     (if (AND (MAP.COPYMESSAGE STREAM MSGNO DESTMAILBOX)
  259.                  (MAP.SETFLAG STREAM MSGNO '\Deleted))
  260.         then DESTMAILBOX])
  261.  
  262. (MAP.ELT
  263.   [LAMBDA (MESSAGEARRAY MSGNO)                           (* ; "Edited 26-Jan-88 17:34 by MRC")
  264.                                                              (* ; 
  265.                                         "Returns extant message record from mailbox or creates one")
  266.     (LET* ((MSG (SUB1 MSGNO))
  267.            (MESSAGERECORD (CL:AREF MESSAGEARRAY MSG)))
  268.           (if (NULL MESSAGERECORD)
  269.               then (replace (MM.CACHE Msg#) of (SETQ MESSAGERECORD
  270.                                                             (CL:SETF (CL:AREF MESSAGEARRAY MSG)
  271.                                                                    (create MM.CACHE)))
  272.                           with MSGNO))
  273.           MESSAGERECORD])
  274.  
  275. (MAP.LOCKED?
  276.   [LAMBDA (STREAM)                                       (* ; "Edited 29-Apr-88 15:26 by MRC")
  277.                                                              (* ; "Returns T if stream locked")
  278.     (IMAP.LOCKED? STREAM])
  279. )
  280.  
  281.  
  282.  
  283. (* ; "Interim Mail Access Protocol support routines")
  284.  
  285. (DEFINEQ
  286.  
  287. (IMAP.OPEN
  288.   [LAMBDA (HOST)                                         (* ; "Edited 29-Apr-88 19:17 by MRC")
  289.                                                              (* ; "Opens an IMAP connection")
  290.     (SELECTQ IMAP.PROTOCOL
  291.         (TCP (IMAP.OPEN.TCP HOST))
  292.         (ERROR "Unknown IMAP protocol" IMAP.PROTOCOL])
  293.  
  294. (IMAP.OPEN.TCP
  295.   [LAMBDA (HOST)                                         (* ; "Edited 28-Jan-88 18:02 by MRC")
  296.                                                              (* ; 
  297.                                                            "Open IMAP connection using TCP/IP")
  298.     (PROG ((HOSTADDR (DODIP.HOSTP HOST))
  299.            STREAM)
  300.           (if HOSTADDR
  301.               then (if (SETQ STREAM (TCP.OPEN HOSTADDR IMAP.PORT.TCP NIL 'ACTIVE 'INPUT T))
  302.                            then (PUTSTREAMPROP STREAM 'OUTSTREAM (TCP.OTHER.STREAM STREAM))
  303.                                  (RETURN STREAM)
  304.                          else (printout PROMPTWINDOW T "Can't connect to " HOST " server"))
  305.             else (printout PROMPTWINDOW T "No such host as " HOST])
  306.  
  307. (IMAP.LOGIN
  308.   [LAMBDA (STREAM HOST)                                  (* ; "Edited 28-Jan-88 15:32 by MRC")
  309.                                                              (* ; "Logs user in to IMAP server")
  310.     (PROG ((LOGINTRYCOUNT -4)
  311.            USRPSW LOGINSUCCESSFLG REPLY)
  312.           [until (OR LOGINSUCCESSFLG (ZEROP (add LOGINTRYCOUNT 1)))
  313.              do (if REPLY
  314.                         then (printout PROMPTWINDOW T "Login failed: " (fetch (
  315.                                                                                      IMAP.PARSEDREPLY
  316.                                                                                        TEXT)
  317.                                                                               of REPLY)))
  318.                    (SETQ USRPSW (\INTERNAL/GETPASSWORD HOST REPLY))
  319.                    [SETQ REPLY (IMAP.SEND STREAM 'LOGIN (LIST (CAR USRPSW)
  320.                                                                   (\ENCRYPT.PWD (CONCAT (CDR USRPSW]
  321.                    (SETQ LOGINSUCCESSFLG (EQ 'OK (fetch (IMAP.PARSEDREPLY KEY) of REPLY]
  322.           (if LOGINSUCCESSFLG
  323.               then (RETURN REPLY)
  324.             else (printout PROMPTWINDOW T "Too many login failures")
  325.                   (IMAP.LOGOUT STREAM])
  326.  
  327. (IMAP.LOGOUT
  328.   [LAMBDA (STREAM)                                       (* ; "Edited 29-Apr-88 18:55 by MRC")
  329.                                                              (* ; "Logs out IMAP session")
  330.     (if STREAM
  331.         then (PROG1 (IMAP.SEND STREAM 'LOGOUT)
  332.                         (CLOSEF? STREAM])
  333.  
  334. (IMAP.NOOP
  335.   [LAMBDA (STREAM)                                       (* ; "Edited  7-Apr-88 15:55 by MRC")
  336.                                                              (* ; 
  337.                          "Send a no-op to the stream; this is to see if the stream is still alive.")
  338.     (if STREAM
  339.         then (PROG [(REPLY (IMAP.SEND STREAM 'NOOP]
  340.                        (with IMAP.PARSEDREPLY REPLY (if (EQ 'OK KEY)
  341.                                                             then (RETURN STREAM)
  342.                                                           else 
  343.                                                              (* ; "We can't no-op.  The stream may be still alive, but with a buggy server that doesn't like no-ops.  In any case, punt it.")
  344.                                                                 (IMAP.LOGOUT STREAM])
  345.  
  346. (IMAP.SELECT
  347.   [LAMBDA (STREAM MAILBOX)                               (* ; "Edited 29-Apr-88 17:08 by MRC")
  348.                                                              (* ; "Select desired mailbox")
  349.     (STREAMPROP STREAM 'NMSGS NIL)                           (* ; 
  350.                                                            "Clear stuff from previous select")
  351.     (STREAMPROP STREAM 'RECENT NIL)
  352.     (PROG ((REPLY (IMAP.SEND STREAM 'SELECT MAILBOX)))
  353.           (with IMAP.PARSEDREPLY REPLY (if (EQ 'OK KEY)
  354.                                                then (RETURN REPLY)
  355.                                              else (printout PROMPTWINDOW T 
  356.                                                              "Can't select mailbox: " TEXT)
  357.                                                    (IMAP.LOGOUT STREAM])
  358.  
  359. (IMAP.SEND
  360.   [LAMBDA (STREAM COMMAND ARGS)                          (* ; "Edited  6-May-88 16:26 by MRC")
  361.                                                              (* ; 
  362.                                                            "Sends an IMAP command to the server")
  363.  
  364.     (* ;; "Note that the strange usage of PRIN3 and MAP.CRLF is to prevent any sort of line folding from being done.")
  365.  
  366.     (if (AND (OPENP STREAM)
  367.                  (NOT (EOFP STREAM)))
  368.         then
  369.         (IMAP.LOCK STREAM)
  370.         (LET ((TAG (GENSYM))
  371.               (OSTREAM (GETSTREAMPROP STREAM 'OUTSTREAM))
  372.               REPLY RTAG LARG)
  373.              (PRIN3 TAG OSTREAM)
  374.              (PRIN3 " " OSTREAM)
  375.              (PRIN3 COMMAND OSTREAM)
  376.              (if IMAP.DEBUG
  377.                  then (printout PROMPTWINDOW T TAG %, COMMAND)
  378.                elseif (NOT IMAP.GAG)
  379.                  then (printout PROMPTWINDOW '+))
  380.              [if ARGS
  381.                  then (RESETFORM (RADIX 10)
  382.                                  (for ARG inside ARGS
  383.                                     do (if (STRPOSL IMAP.ARGBITTABLE ARG)
  384.                                                then (PRIN3 " {" OSTREAM)
  385.                                                      (PRIN3 (SETQ LARG (NCHARS ARG))
  386.                                                             OSTREAM)
  387.                                                      (PRIN3 "}" OSTREAM)
  388.                                                      (if IMAP.DEBUG
  389.                                                          then (printout PROMPTWINDOW " {" LARG 
  390.                                                                          "}"))
  391.                                                      (PRIN3 MAP.CRLF OSTREAM)
  392.                                                      (FORCEOUTPUT OSTREAM T)
  393.                                                      (SETQ REPLY (IMAP.REPLY STREAM TAG))
  394.                                                      (if (EQ (CAR REPLY)
  395.                                                                  '+)
  396.                                                          then (PRIN3 ARG OSTREAM)
  397.                                                                (SETQ REPLY NIL)
  398.                                                        else (RETURN))
  399.                                              else (PRIN3 " " OSTREAM)
  400.                                                    (if (STRPOSL IMAP.SPACEBITTABLE ARG)
  401.                                                        then (PRIN4 ARG OSTREAM)
  402.                                                      else (PRIN3 ARG OSTREAM))
  403.                                                    (if IMAP.DEBUG
  404.                                                        then (printout PROMPTWINDOW %, ARG]
  405.              (if (NULL REPLY)
  406.                  then (PRIN3 MAP.CRLF OSTREAM)
  407.                        (FORCEOUTPUT OSTREAM T)
  408.                        (SETQ REPLY (IMAP.REPLY STREAM TAG)))
  409.              (while (NEQ TAG (SETQ RTAG (CAR REPLY)))
  410.                 do (SELECTQ RTAG
  411.                            (* (IMAP.PARSE.UNSOLICITED STREAM REPLY))
  412.                            (printout PROMPTWINDOW T "Unexpected tagged response: " REPLY))
  413.                       (SETQ REPLY (IMAP.REPLY STREAM TAG)))
  414.              (with IMAP.PARSEDREPLY REPLY (if (EQ 'BAD KEY)
  415.                                                   then (printout PROMPTWINDOW T 
  416.                                                                   "IMAP II protocol error: " TEXT)))
  417.              (IMAP.UNLOCK STREAM)
  418.              REPLY)
  419.       else (create IMAP.PARSEDREPLY
  420.                       TAG _ '*
  421.                       KEY _ 'BYE
  422.                       TEXT _ "IMAP connection went away!"])
  423.  
  424. (IMAP.REPLY
  425.   [LAMBDA (STREAM CTAG)                                  (* ; "Edited 20-May-88 12:15 by MRC")
  426.                                                              (* ; 
  427.                                                            "Reads a reply string from the server")
  428.     (if (AND (OPENP STREAM)
  429.                  (NOT (EOFP STREAM)))
  430.         then (LET ((REPLY (RSTRING STREAM IMAP.CR.RDTBL))
  431.                        TAG KEY TAGPOS KEYPOS)
  432.                       (while (ZEROP (NCHARS REPLY))
  433.                          do (if IMAP.DEBUG
  434.                                     then (printout PROMPTWINDOW T "IMAP server sent a blank line"
  435.                                                     ))
  436.                                (to (CONSTANT (NCHARS MAP.CRLF)) do (BIN STREAM))
  437.                                (SETQ REPLY (RSTRING STREAM IMAP.CR.RDTBL)))
  438.                       (if IMAP.DEBUG
  439.                           then (printout PROMPTWINDOW T REPLY)
  440.                         elseif (NOT IMAP.GAG)
  441.                           then (printout PROMPTWINDOW '!))
  442.                       (to (CONSTANT (NCHARS MAP.CRLF)) do (BIN STREAM))
  443.                                                              (* ; "Slurp TCP/IP newline")
  444.                       (if [AND (SETQ TAGPOS (STRPOSL IMAP.SPACEBITTABLE REPLY))
  445.                                    [SETQ TAG (U-CASE (SUBATOM REPLY 1 (SUB1 TAGPOS]
  446.                                    (SETQ KEY (U-CASE (SUBATOM REPLY (ADD1 TAGPOS)
  447.                                                             (SUB1 (SETQ KEYPOS
  448.                                                                    (OR (STRPOSL IMAP.SPACEBITTABLE 
  449.                                                                               REPLY (ADD1 TAGPOS))
  450.                                                                        (ADD1 (NCHARS REPLY]
  451.                           then (create IMAP.PARSEDREPLY
  452.                                           TAG _ TAG
  453.                                           KEY _ KEY
  454.                                           TEXT _ (SUBSTRING REPLY (ADD1 KEYPOS)))
  455.                         else (printout PROMPTWINDOW T "Bogus IMAP response: " REPLY)
  456.                               (create IMAP.PARSEDREPLY
  457.                                      TAG _ '*
  458.                                      KEY _ 'BAD
  459.                                      TEXT _ REPLY)))
  460.       else (create IMAP.PARSEDREPLY
  461.                       TAG _ (OR CTAG '*)
  462.                       KEY _ 'BYE
  463.                       TEXT _ "IMAP connection went away!"])
  464.  
  465. (IMAP.PARSE.UNSOLICITED
  466.   [LAMBDA (STREAM REPLY)                                 (* ; "Edited 25-Apr-88 08:52 by cdl")
  467.                                                              (* ; "Parse an unsolicited IMAP reply")
  468.     (LET (TEMP OP)
  469.          (with IMAP.PARSEDREPLY REPLY
  470.                 (if (NUMBERP KEY)
  471.                     then (if (SETQ TEMP (STRPOSL IMAP.SPACEBITTABLE TEXT))
  472.                                  then [SETQ OP (U-CASE (SUBATOM TEXT 1 (SUB1 TEMP]
  473.                                        (SETQ TEXT (SUBSTRING TEXT (ADD1 TEMP)))
  474.                                else (SETQ OP (U-CASE (MKATOM TEXT)))
  475.                                      (SETQ TEXT NIL))
  476.                           (SELECTQ OP
  477.                               (EXISTS (IMAP.EXISTS STREAM KEY))
  478.                               (RECENT (IMAP.RECENT STREAM KEY))
  479.                               (EXPUNGE (IMAP.EXPUNGED STREAM KEY))
  480.                               ((STORE FETCH) 
  481.                                    (if (GETSTREAMPROP STREAM 'MESSAGEARRAY)
  482.                                        then (IMAP.PARSE.DATA STREAM KEY TEXT)
  483.                                      else (printout PROMPTWINDOW T "Unexpected message data: " 
  484.                                                      REPLY)))
  485.                               (COPY (printout (GETPROMPTWINDOW (STREAMPROP STREAM 'TWINDOW))
  486.                                            T "Message(s) copied"))
  487.                               (printout PROMPTWINDOW T "Unknown message data: " OP %, REPLY))
  488.                   else (SELECTQ KEY
  489.                                (FLAGS (PUTSTREAMPROP STREAM 'FLAGLST (CL:READ-FROM-STRING TEXT)))
  490.                                (SEARCH (IMAP.SEARCHED STREAM TEXT))
  491.                                (BYE (printout PROMPTWINDOW T TEXT))
  492.                                (OK NIL)
  493.                                (NO (printout PROMPTWINDOW T "Error from IMAP II server: " TEXT))
  494.                                (BAD (printout PROMPTWINDOW T "IMAP II protocol error: " TEXT))
  495.                                (printout PROMPTWINDOW T "Unexpected unsolicited message: " REPLY])
  496.  
  497. (IMAP.EXISTS
  498.   [LAMBDA (STREAM NMSGS)                                 (* ; "Edited 28-Mar-88 09:29 by cdl")
  499.                                                              (* ; 
  500.                                                      "Server has notified us of a new message size")
  501.     (MM.EXISTS NMSGS STREAM)
  502.     (PUTSTREAMPROP STREAM 'NMSGS NMSGS])
  503.  
  504. (IMAP.RECENT
  505.   [LAMBDA (STREAM NMSGS)                                 (* ; "Edited 25-Feb-88 17:57 by MRC")
  506.                                                              (* ; 
  507.                                                         "Server has notified us of recent messages")
  508.     (PUTSTREAMPROP STREAM 'RECENT NMSGS])
  509.  
  510. (IMAP.EXPUNGED
  511.   [LAMBDA (STREAM MSG)                                   (* ; "Edited  5-Aug-87 16:33 by MRC")
  512.                                                              (* ; 
  513.                                                     "Server has notified us of an expunged message")
  514.     (MM.EXPUNGED (GETSTREAMPROP STREAM 'TWINDOW)
  515.            MSG)
  516.     (PUTSTREAMPROP STREAM 'NMSGS (SUB1 (GETSTREAMPROP STREAM 'NMSGS])
  517.  
  518. (IMAP.SEARCHED
  519.   [LAMBDA (STREAM TEXT)                                  (* ; "Edited 28-Mar-88 09:45 by cdl")
  520.                                                              (* ; 
  521.                                                         "Here when server gives us a search string")
  522.     (LET ((SELECTED 0))
  523.          [if TEXT
  524.              then (bind (STR _ (OPENSTRINGSTREAM TEXT))
  525.                              (WINDOW _ (GETSTREAMPROP STREAM 'TWINDOW)) until (EOFP STR)
  526.                          as old SELECTED from 0 do (MM.SEARCHED WINDOW (READ STR]
  527.          (printout (GETPROMPTWINDOW (STREAMPROP STREAM 'TWINDOW))
  528.                 T
  529.                 (if (ZEROP SELECTED)
  530.                     then "No"
  531.                   else SELECTED)
  532.                 " message"
  533.                 (if (EQ SELECTED 1)
  534.                     then " "
  535.                   else "s ")
  536.                 "selected")
  537.          SELECTED])
  538.  
  539. (IMAP.PARSE.DATA
  540.   [LAMBDA (STREAM MSG TEXT)                              (* ; "Edited 28-Jan-88 16:10 by MRC")
  541.                                                              (* ; "Parse message data from server")
  542.     (LET ((DATA (IMAP.READ TEXT STREAM))
  543.           VALUE KEY)
  544.          (with MM.CACHE (MAP.ELT (GETSTREAMPROP STREAM 'MESSAGEARRAY)
  545.                                    MSG)
  546.                 (for PAIR on DATA by (CDDR PAIR)
  547.                    do (SETQ VALUE (CADR PAIR))
  548.                          (SELECTQ (U-CASE (SETQ KEY (CAR PAIR)))
  549.                              (ENVELOPE (SETQ Envelope VALUE))
  550.                              (FLAGS (SETQ Flags VALUE))
  551.                              (INTERNALDATE (SETQ InternalDate VALUE))
  552.                              (RFC822 (SETQ RFC822.Stream VALUE))
  553.                              (RFC822.HEADER (SETQ RFC822.Header VALUE))
  554.                              (RFC822.SIZE (SETQ RFC822.Size VALUE))
  555.                              (RFC822.TEXT (SETQ RFC822.Stream VALUE))
  556.                              (printout PROMPTWINDOW T "Unknown message property: " KEY " value: " 
  557.                                     VALUE])
  558.  
  559. (IMAP.READ
  560.   [LAMBDA (TEXT STREAM)                                  (* ; "Edited 25-Mar-88 08:00 by cdl")
  561.                                                              (* ; 
  562.                                       "Read IMAP-format S-expression including curly-brace quoting")
  563.     (if (NEQ (NTHCHARCODE TEXT 1)
  564.                  (CHARCODE %())
  565.         then (ERROR "Bogus IMAP II data:" TEXT))
  566.     (if (EQ (NTHCHARCODE TEXT -1)
  567.                 (CHARCODE %)))
  568.         then (CL:READ-FROM-STRING TEXT)
  569.       else (LET ((RSTREAM (OPENSTRINGSTREAM TEXT))
  570.                      PROP)
  571.                     (BIN RSTREAM)                            (* ; 
  572.                                              "move the stream pointer past the initial parenthesis")
  573.                     (PUTSTREAMPROP STREAM 'RSTREAM RSTREAM)
  574.                     (while [SETQ PROP (U-CASE (READ (SETQ RSTREAM (GETSTREAMPROP STREAM
  575.                                                                              'RSTREAM]
  576.                        join (LIST PROP (IMAP.READ.ITEM PROP STREAM))
  577.                        finally (if (EQ RSTREAM STREAM)
  578.                                        then (to (CONSTANT (NCHARS MAP.CRLF))
  579.                                                    do (BIN STREAM)))
  580.                              (PUTSTREAMPROP STREAM 'RSTREAM NIL])
  581.  
  582. (IMAP.READ.ITEM
  583.   [LAMBDA (PROP STREAM)                                  (* ; "Edited 28-Mar-88 18:23 by cdl")
  584.                                                              (* ; 
  585.                        "Read an item (atom or list) from STREAM, switching to RSTREAM if necessary")
  586.     (LET ((RSTREAM (GETSTREAMPROP STREAM 'RSTREAM))
  587.           LEN VALUE)
  588.          (while (EQ (CHARCODE SPACE)
  589.                         (\PEEKBIN RSTREAM)) do (BIN RSTREAM))
  590.          (if (EQ (CHARCODE %()
  591.                      (\PEEKBIN RSTREAM))
  592.              then (BIN RSTREAM)
  593.                    [while [NOT (EQ (CHARCODE %))
  594.                                        (\PEEKBIN (GETSTREAMPROP STREAM 'RSTREAM]
  595.                       collect (IMAP.READ.ITEM PROP STREAM)
  596.                       finally (BIN (GETSTREAMPROP STREAM 'RSTREAM]
  597.            else (SETQ VALUE (READ RSTREAM))
  598.                  (if (AND (EQ (NTHCHARCODE VALUE 1)
  599.                                   (CHARCODE {))
  600.                               (EQ (NTHCHARCODE VALUE -1)
  601.                                   (CHARCODE })))
  602.                      then (if (NEQ STREAM RSTREAM)
  603.                                   then (SETQ RSTREAM STREAM)
  604.                                         (PUTSTREAMPROP STREAM 'RSTREAM STREAM)
  605.                                 else (to (CONSTANT (NCHARS MAP.CRLF))
  606.                                             do (BIN STREAM)))
  607.                            (SETQ LEN (SUBATOM VALUE 2 -2))
  608.                            (if (FMEMB PROP '(RFC822 RFC822.TEXT))
  609.                                then [SETQ VALUE (OPENSTREAM '{NODIRCORE} 'BOTH NIL
  610.                                                            '((EOL CRLF]
  611.                                      (COPYBYTES RSTREAM VALUE LEN)
  612.                                      (SETFILEPTR VALUE 0)
  613.                              else (SETQ VALUE (ALLOCSTRING LEN))
  614.                                    (COPYBYTES RSTREAM (OPENSTRINGSTREAM VALUE 'OUTPUT)
  615.                                           LEN)))
  616.                  VALUE])
  617.  
  618. (IMAP.LOCK
  619.   [LAMBDA (STREAM)                                       (* ; "Edited  7-Apr-88 16:43 by MRC")
  620.                                                              (* ; "Locks the IMAP stream")
  621.     (while (STREAMPROP STREAM 'IMAPLOCK T) do (if IMAP.LOCKDEBUG
  622.                                                           then (printout PROMPTWINDOW T 
  623.                                                                           "Waiting for IMAP lock...")
  624.                                                              )
  625.                                                      (DISMISS 100))
  626.     (if IMAP.LOCKDEBUG
  627.         then (printout PROMPTWINDOW T '<])
  628.  
  629. (IMAP.UNLOCK
  630.   [LAMBDA (STREAM)                                       (* ; "Edited  7-Apr-88 16:40 by MRC")
  631.                                                              (* ; "Unlocks the IMAP stream")
  632.     (if (STREAMPROP STREAM 'IMAPLOCK NIL)
  633.         then (if IMAP.LOCKDEBUG
  634.                      then (printout PROMPTWINDOW '>))
  635.       else (ERROR "IMAP unlock when already unlocked"])
  636.  
  637. (IMAP.LOCKED?
  638.   [LAMBDA (STREAM)                                       (* ; "Edited 29-Apr-88 15:26 by MRC")
  639.                                                              (* ; "Returns T if stream locked")
  640.     (STREAMPROP STREAM 'IMAPLOCK])
  641. )
  642.  
  643.  
  644.  
  645. (* ; "IMAP contact ports")
  646.  
  647. (DECLARE%: EVAL@COMPILE 
  648.  
  649. (RPAQQ IMAP.PORT.TCP 143)
  650.  
  651.  
  652. (CONSTANTS (IMAP.PORT.TCP 143))
  653. )
  654.  
  655.  
  656.  
  657. (* ; "Single line string readtable")
  658.  
  659.  
  660. (RPAQ? IMAP.CR.RDTBL (COPYREADTABLE 'ORIG))
  661.  
  662. (for I from 0 to 127 do (SETSYNTAX I 'OTHER IMAP.CR.RDTBL))
  663.  
  664. (SETSYNTAX (CHARCODE CR)
  665.        'BREAKCHAR IMAP.CR.RDTBL)
  666.  
  667.  
  668.  
  669. (* ; "Commonly used strings and bittables")
  670.  
  671.  
  672. (RPAQ? MAP.CRLF (CONCAT (CHARACTER (CHARCODE CR))
  673.                            (CHARACTER (CHARCODE LF))))
  674.  
  675. (RPAQ? MAP.LOOKAHEAD 20)
  676.  
  677. (RPAQ? IMAP.SPACEBITTABLE (MAKEBITTABLE (LIST (CHARCODE SPACE))))
  678.  
  679. (RPAQ? IMAP.ARGBITTABLE (MAKEBITTABLE (LIST (CHARCODE CR)
  680.                                                 (CHARCODE "%"")
  681.                                                 (CHARCODE {))))
  682.  
  683.  
  684.  
  685. (* ; "IMAP user-settable parameters")
  686.  
  687.  
  688. (RPAQ? IMAP.PROTOCOL 'TCP)
  689.  
  690. (RPAQ? IMAP.DEBUG NIL)
  691.  
  692. (RPAQ? IMAP.GAG T)
  693.  
  694. (RPAQ? IMAP.LOCKDEBUG NIL)
  695.  
  696.  
  697.  
  698. (* ; "Declare all globals")
  699.  
  700. (DECLARE%: DOEVAL@COMPILE DONTCOPY
  701.  
  702. (GLOBALVARS MAP.CRLF MAP.LOOKAHEAD IMAP.SPACEBITTABLE IMAP.ARGBITTABLE 
  703.        IMAP.CR.RDTBL IMAP.PORT.TCP IMAP.PROTOCOL IMAP.DEBUG IMAP.GAG 
  704.        IMAP.LOCKDEBUG PROMPTWINDOW)
  705. )
  706.  
  707.  
  708.  
  709. (* ; "IMAP reply record")
  710.  
  711. (DECLARE%: EVAL@COMPILE
  712.  
  713. (RECORD IMAP.PARSEDREPLY (TAG KEY TEXT))
  714. )
  715. (DECLARE%: DONTCOPY
  716.   (FILEMAP (NIL (3176 16250 (MAP.OPEN 3186 . 4877) (MAP.CLOSE 4879 . 5242) (
  717. MAP.SELECT 5244 . 5580) (MAP.FETCHFLAGS 5582 . 6036) (MAP.FETCHENVELOPE 6038 . 
  718. 7316) (MAP.FETCHMESSAGE 7318 . 7740) (MAP.FETCHHEADER 7742 . 8165) (
  719. MAP.FETCHFROMSTRING 8167 . 9684) (MAP.FETCHSUBJECT 9686 . 10733) (MAP.SETFLAG 
  720. 10735 . 11534) (MAP.CLEARFLAG 11536 . 12341) (MAP.CHECKMAILBOX 12343 . 12977) (
  721. MAP.EXPUNGEMAILBOX 12979 . 13953) (MAP.COPYMESSAGE 13955 . 14864) (
  722. MAP.MOVEMESSAGE 14866 . 15244) (MAP.ELT 15246 . 15996) (MAP.LOCKED? 15998 . 
  723. 16248)) (16313 37731 (IMAP.OPEN 16323 . 16659) (IMAP.OPEN.TCP 16661 . 17453) (
  724. IMAP.LOGIN 17455 . 18766) (IMAP.LOGOUT 18768 . 19098) (IMAP.NOOP 19100 . 19986) 
  725. (IMAP.SELECT 19988 . 20852) (IMAP.SEND 20854 . 24708) (IMAP.REPLY 24710 . 27347)
  726.  (IMAP.PARSE.UNSOLICITED 27349 . 29542) (IMAP.EXISTS 29544 . 29909) (IMAP.RECENT
  727.  29911 . 30248) (IMAP.EXPUNGED 30250 . 30682) (IMAP.SEARCHED 30684 . 31659) (
  728. IMAP.PARSE.DATA 31661 . 32855) (IMAP.READ 32857 . 34247) (IMAP.READ.ITEM 34249
  729.  . 36359) (IMAP.LOCK 36361 . 37050) (IMAP.UNLOCK 37052 . 37472) (IMAP.LOCKED? 
  730. 37474 . 37729)))))
  731. STOP
  732.